home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
turbovis
/
dlgds411.zip
/
PASRSRC.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-08-03
|
10KB
|
424 lines
{$A-,B-,E+,F-,G-,I+,N-,O-,P-,Q-,R-,S-,T-,V-,X+}
{$M 16384,5000,655360}
Program ScriptToResource;
uses Dos, Memory, Objects, Drivers, Views, Dialogs,
Editors, ColorTxt, InpLong, Validate, ReadScpt;
var
Dlg : PDialog; {holds the dialog as it's constructed and controls added}
Control : PView;
HScrollBar : PScrollBar;
procedure Error(const S : string);
begin
WriteLn(S);
Halt(1);
end;
procedure DoOptionsEtc(P : PView; S : PScriptRec);
begin
with S^, MainBlock, P^ do
begin
Options := Optns;
EventMask := EvMsk;
HelpCtx := HCtx;
GrowMode := Grow;
end;
end;
procedure DoButton(P : PScriptRec);
var
R : TRect;
begin
with P^, MainBlock do
begin
R.Assign(X1, Y1, X2, Y2);
Control := New(PButton, Init(R, ButtonText^, CommandValue, Flags));
if Control <> Nil then
begin
DoOptionsEtc(Control, P);
Dlg^.Insert(Control);
end
else
Error('Cannot construct TButton');
end;
end;
procedure DoListBox(P : PScriptRec);
var
R : TRect;
begin
with P^, MainBlock do
begin
R.Assign(X1, Y1, X2, Y2);
if ScrollBar^ <> '' then
Control := New(PListBox, Init(R, Columns, PScrollBar(Control)))
else Control := New(PListBox, Init(R, Columns, Nil));
if Control <> Nil then
begin
DoOptionsEtc(Control, P);
Dlg^.Insert(Control);
end
else
Error('Cannot construct TListBox');
end;
end;
procedure DoCheckRadio(P : PScriptRec);
var
R : TRect;
LastItem : PSItem;
I : integer;
begin
with P^, MainBlock do
begin
R.Assign(X1, Y1, X2, Y2);
LastItem := Nil;
for I := Items-1 downto 0 do {this has to be done backwards}
LastItem := NewSItem(PString(LabelColl^.At(I))^, LastItem);
case Kind of
CheckB:
Control := New(PCheckBoxes, Init(R, LastItem));
RadioB:
Control := New(PRadioButtons, Init(R, LastItem));
MultiCB:
Control := New(PMultiCheckBoxes, Init(R, LastItem, SelRange,
MCBFlags, States^));
end;
if Control <> Nil then
begin
DoOptionsEtc(Control, P);
PCluster(Control)^.SetButtonState(not Mask, False);
Dlg^.Insert(Control);
end
else
case Kind of
CheckB:
Error('Cannot construct TCheckBoxes');
RadioB:
Error('Cannot construct TRadioButtons');
MultiCB:
Error('Cannot construct TMultiCheckBoxes');
end;
end;
end;
procedure DoInputLong(P : PScriptRec);
var
R : TRect;
begin
with P^, MainBlock do
begin
R.Assign(X1, Y1, X2, Y2);
Control := New(PInputLong, Init(R, LongStrLeng, LLim, ULim, ILOptions));
if Control <> Nil then
begin
DoOptionsEtc(Control, P);
Dlg^.Insert(Control);
end
else
Error('Cannot construct TInputLong');
end;
end;
procedure DoStaticText(P : PScriptRec);
var
R : TRect;
begin
with P^, MainBlock do
begin
R.Assign(X1, Y1, X2, Y2);
case Kind of
SText :
Control := New(PStaticText, Init(R, Text^));
CText :
Control := New(PColoredText, Init(R, Text^, Attrib));
end;
if Control <> Nil then
begin
DoOptionsEtc(Control, P);
Dlg^.Insert(Control);
end
else
Error('Cannot construct '+BaseObj^);
end;
end;
procedure DoMemo(P : PScriptRec);
var
R : TRect;
Vbar, Hbar : PScrollBar;
begin
with P^, MainBlock do
begin
R.Assign(X1, Y1, X2, Y2);
if VScroll^ <> '' then VBar := PScrollBar(Control)
else VBar := Nil;
if HScroll^ <> '' then HBar := HScrollBar
else HBar := Nil;
Control := New(PMemo, Init(R, Hbar, Vbar, Nil, BufSize));
if Control <> Nil then
begin
DoOptionsEtc(Control, P);
Dlg^.Insert(Control);
end
else
Error('Cannot construct TMemo');
end;
end;
procedure DoLabel(P : PScriptRec);
var
R : TRect;
Labl : PLabel;
begin
with P^, MainBlock do
begin
R.Assign(X1, Y1, X2, Y2);
Labl := New(PLabel, Init(R, LabelText^, Control));
if Labl <> Nil then
begin
DoOptionsEtc(Labl, P);
Dlg^.Insert(Labl);
end
else
Error('Cannot construct TLabel');
end;
end;
procedure DoScrollBar(P : PScriptRec);
var
R : TRect;
Tmp : PScrollBar;
begin
with P^, MainBlock do
begin
R.Assign(X1, Y1, X2, Y2);
Tmp := New(PScrollBar, Init(R));
if Tmp <> Nil then
begin
DoOptionsEtc(Tmp, P);
Dlg^.Insert(Tmp);
if SameString(VarName^, 'HScroll') then
HScrollBar := Tmp {probably a horizontal scrollbar for TMemo}
else Control := Tmp;
end
else
Error('Cannot construct TScrollBar');
end;
end;
procedure DoHistory(P : PScriptRec);
var
R : TRect;
History : PHistory;
begin
with P^, MainBlock do
begin
R.Assign(X1, Y1, X2, Y2);
History := New(PHistory, Init(R, PInputLine(Control), HistoryID));
if History <> Nil then
begin
DoOptionsEtc(History, P);
Dlg^.Insert(History);
end
else
Error('Cannot construct THistory');
end;
end;
procedure DoInputLine(P : PScriptRec);
var
R : TRect;
Val : PValidator;
begin
with P^, MainBlock do
begin
R.Assign(X1, Y1, X2, Y2);
Control := New(PInputLine, Init(R, StringLeng));
if Control <> Nil then
begin
DoOptionsEtc(Control, P);
Dlg^.Insert(Control);
if ValKind in [Picture..StringLookup] then
begin
Val := Nil;
case ValKind of
Picture:
Val := New(PPXPictureValidator, Init(PictureString^, AutoFill <> 0));
Range:
begin
Val := New(PRangeValidator, Init(LowLim, UpLim));
if (Val <> Nil) and (Transfer <> 0) then
Val^.Options := voTransfer;
end;
Filter:
Val := New(PFilterValidator, Init(TCharSet(ActualCharSet)));
StringLookup:
Val := New(PStringLookupValidator, Init(Nil));
end;
if Val <> Nil then PInputLine(Control)^.Validator := Val
else Error('Cannot construct Validator');
end;
end
else
Error('Cannot construct TInputLine');
end;
end;
procedure DoDialog;
var
R : TRect;
begin
with Dialog^, MainBlock do
begin
R.Assign(X1, Y1, X2, Y2);
Dlg := New(PDialog, Init(R, Title^));
if Dlg <> Nil then
begin
DoOptionsEtc(Dlg, Dialog);
Dlg^.Palette := Dialog^.Palette;
Dlg^.Flags := Dialog^.WinFlags;
end
else
Error('Cannot construct Dialog');
end;
end;
procedure MakeResource;
procedure DoControls(P : PScriptRec); far;
begin
case P^.Kind of
Button: DoButton(P);
InputL: DoInputLine(P);
Labl: DoLabel(P);
Histry: DoHistory(P);
ILong: DoInputLong(P);
CheckB, RadioB, MultiCB:
DoCheckRadio(P);
ListB: DoListBox(P);
ScrollB: DoScrollBar(P);
Memo: DoMemo(P);
CText, SText: DoStaticText(P);
end;
end;
begin
DoDialog;
ScriptColl^.ForEach(@DoControls);
Dlg^.SelectNext(False);
end;
procedure WriteResource;
var
Strm, StrmBKP : PBufStream;
Rsrc : TResourceFile;
FileNameBKP, S : PathStr;
Name : NameStr;
Ext : ExtStr;
F : File;
IOR, Value : Word;
Check1 : Array[1..4] of char;
Check2 : Array[1..2] of char absolute Check1;
begin
MakeResource; {dialog is now in 'Dlg'}
S := DefaultExt( ParamStr(2), '.REZ');
if FSearch(S, '') <> '' then
begin
{$I-}
Assign(F, S);
Reset(F,1);
if IOResult <> 0 then
Error('Could not open '+S);
BlockRead(F, Check1, Sizeof(Check1));
{EXE files start with 'MZ'}
if Check2 = 'MZ' then {Check2 has same address as Check1}
begin {an EXE file}
Seek(F, $18);
BlockRead(F, Value, Sizeof(Value));
Close(F);
{$ifdef DPMI}
if Value < $40 then
Error('Can''t write resource to old type EXE file');
{$else}
if Value >= $40 then
Error('Can''t write resource to new type EXE file (DPMI or Windows)');
{$endif}
end
else if Check1 <> 'FBPR' then {REZ files start with 'FBPR'}
Error('File exists but is not a resource or EXE file');
{Back up the existing file}
FSplit(S, FileNameBKP, Name, Ext);
FileNameBKP := FileNameBKP + Na